home *** CD-ROM | disk | FTP | other *** search
VERSION 4.00 Begin VB.Form ControlPanel BackColor = &H00FFFFFF& BorderStyle = 4 'Fixed ToolWindow Caption = "Internet Mail" ClientHeight = 3585 ClientLeft = 1020 ClientTop = 1485 ClientWidth = 8445 Height = 3990 Icon = "CtrlPan.frx":0000 Left = 960 LinkTopic = "Form1" LockControls = -1 'True MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 3585 ScaleWidth = 8445 ShowInTaskbar = 0 'False Top = 1140 Width = 8565 Begin VB.Label lblReadMe BackStyle = 0 'Transparent Caption = "Common Dialog control used to work with files." ForeColor = &H00800000& Height = 645 Index = 3 Left = 6060 TabIndex = 7 Top = 2910 Visible = 0 'False Width = 2055 WordWrap = -1 'True End Begin MSComDlg.CommonDialog ComDialog Left = 5475 Top = 2895 _ExtentX = 847 _ExtentY = 847 _Version = 327681 CancelError = -1 'True Filter = "All Files (*.*)|*.*" FilterIndex = 1 FontSize = 2.54052e-29 End Begin VB.Image Exit Height = 435 Left = 4140 MouseIcon = "CtrlPan.frx":0442 MousePointer = 99 'Custom Picture = "CtrlPan.frx":0594 Top = 3030 Width = 870 End Begin VB.Label MailProperties BackStyle = 0 'Transparent Height = 420 Left = 555 MouseIcon = "CtrlPan.frx":10A2 MousePointer = 99 'Custom TabIndex = 6 Top = 1650 Width = 4425 End Begin VB.Label GetMail BackStyle = 0 'Transparent Height = 420 Left = 555 MouseIcon = "CtrlPan.frx":11F4 MousePointer = 99 'Custom TabIndex = 5 Top = 975 Width = 2895 End Begin VB.Label SendMail BackStyle = 0 'Transparent Height = 420 Left = 615 MouseIcon = "CtrlPan.frx":1346 MousePointer = 99 'Custom TabIndex = 4 Top = 315 Width = 3225 End Begin VB.Line lneBorder BorderColor = &H00808080& BorderWidth = 3 Index = 1 X1 = 135 X2 = 4980 Y1 = 2400 Y2 = 2400 End Begin VB.Line lneBorder BorderColor = &H00808080& BorderWidth = 2 Index = 0 X1 = 300 X2 = 300 Y1 = 90 Y2 = 2625 End Begin VB.Image ButtonImages Height = 2010 Left = 435 Picture = "CtrlPan.frx":1498 Top = 210 Width = 4590 End Begin VB.Image MailLogo Height = 870 Left = 570 MouseIcon = "CtrlPan.frx":BA12 MousePointer = 99 'Custom Picture = "CtrlPan.frx":BB64 Top = 2595 Width = 2895 End Begin VB.Label lblReadMe AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "MIME control is used to encode and decode attachments." ForeColor = &H00800000& Height = 390 Index = 2 Left = 6060 TabIndex = 3 Top = 1335 Visible = 0 'False Width = 2295 WordWrap = -1 'True End Begin VB.Label lblReadMe BackStyle = 0 'Transparent Caption = "POP control is used to receive mail." ForeColor = &H00800000& Height = 510 Index = 1 Left = 6060 TabIndex = 2 Top = 765 Visible = 0 'False Width = 2265 WordWrap = -1 'True End Begin VB.Label lblReadMe BackStyle = 0 'Transparent Caption = "SMTP control is used to send mail." ForeColor = &H00800000& Height = 510 Index = 0 Left = 6060 TabIndex = 1 Top = 195 Visible = 0 'False Width = 2265 WordWrap = -1 'True End Begin CIMIMELib.CIMIME MimeControl Height = 450 Left = 5460 Top = 1335 Width = 480 _Version = 65537 _ExtentX = 847 _ExtentY = 794 _StockProps = 0 SourceFilename = "" DestinationFilename= "C:\$$$CIMIME.TMP" ProgressDialogVisible= -1 'True End Begin CIMAILLib.CIPOP PopControl Height = 450 Left = 5460 Top = 735 Width = 480 _Version = 65536 _ExtentX = 847 _ExtentY = 794 _StockProps = 0 POPServerConnectionWAV= "" POPServerConnectionClosedWAV= "" MessageReceivedWAV= "" STATReceivedWAV = "" PacketReceivedWAV= "" PacketSentWAV = "" SocketClosedWAV = "" WSAErrorWAV = "" LocalFileName = "" HostAddress = "" HostName = "" MessageNumber = "" Password = "" UserName = "" End Begin VB.Label CrescentLabel AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Crescent Internet ToolPak" BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = -1 'True Strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 240 Left = 5400 TabIndex = 0 Top = 2490 Visible = 0 'False Width = 3030 WordWrap = -1 'True End Begin CIMAILLib.CISMTP SMTPControl Height = 450 Left = 5460 Top = 165 Width = 480 _Version = 65536 _ExtentX = 847 _ExtentY = 794 _StockProps = 0 SMTPServerConnectionWAV= "" SMTPServerConnectionClosedWAV= "" ListBoxPopulatedWAV= "" PacketReceivedWAV= "" PacketSentWAV = "" SocketClosedWAV = "" WSAErrorWAV = "" HostName = "" HostAddress = "" DomainName = "" Sender = "" Recipient = "" MailList = "" MessageBody = "" MessageSubject = "" CC = "" BC = "" End Attribute VB_Name = "ControlPanel" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit '<Contant>----------------------------------------------- Const ciMaxSendMsg As Integer = 10 Const ciMaxReceiveMsg As Integer = 10 '</Contant>---------------------------------------------- '<Private>----------------------------------------------- Private ReceiveForms(ciMaxReceiveMsg) As Form Private SendForms(ciMaxSendMsg) As Form Private Attachments() As String Private NumAttachments As Integer '</Private>---------------------------------------------- '<Public>------------------------------------------------ Public IsAttachment As Boolean Public CurrentSendForm As Form '</Public>----------------------------------------------- Private Sub MimeControl_DecodingFile(FileName As String, ByVal ContentType As String, ByVal ContentEncoding As String) '-- This event fires for each MIME part in a message Dim UpBound As Integer Static AttachPath As String If Len(AttachPath) = 0 Then AttachPath = App.Path If right$(AttachPath, 1) <> "\" Then AttachPath = AttachPath + "\" End If '-- If we have a filename, then it is an attachment If Len(FileName) Then UpBound = UBound(Attachments) + 1 ReDim Preserve Attachments(0 To UpBound) FileName = AttachPath & FileName Attachments(UpBound) = FileName NumAttachments = UpBound '-- Otherwise, it is either the message body, or some other type '-- TEXT/PLAIN is usually the message. Save it to a file for later retrieval If UCase$(left$(ContentType, 11)) = "TEXT/PLAIN" Then FileName = "C:\$$BODY.TXT" Attachments(0) = FileName '-- Treat TEXT/HTML as an attachment since this application can not display it ElseIf UCase$(left$(ContentType, 10)) = "TEXT/HTML" Then UpBound = UBound(Attachments) + 1 ReDim Preserve Attachments(0 To UpBound) FileName = GetNewFilename(AttachPath, ".html") Attachments(UpBound) = FileName NumAttachments = UpBound End If End If End Sub Private Function GetNewFilename(ByVal FilePath As String, ByVal FileExt As String) As String Dim strName As String Dim nCount As Integer nCount = 1 strName = FilePath & "MailMessage" & nCount & FileExt strName = Dir(strName) Do While Len(strName) nCount = nCount + 1 strName = FilePath & "MailMessage" & nCount & FileExt strName = Dir(strName) GetNewFilename = "MailMessage" & nCount & FileExt End Function Private Sub MimeControl_DecodingFinished(ByVal Error As Integer) NumAttachments = NumAttachments - 1 End Sub Private Sub MimeControl_EncodingFinished(ByVal Error As Integer) '---- Allow refresh of main screen DoEvents If (Error = 1) Then Unload CurrentSendForm Call Status.ShowStatus("An error occurred, unable to encode message.", vbRed, True, "Error", vbBlack) Exit Sub End If Call SendMailMessage(True) Unload CurrentSendForm End Sub Private Sub PopControl_MessageReceived() '---- message received on the access control channel Call Status.ShowStatus("Message received", vbBlack, , "Status", vbRed) End Sub Private Sub PopControl_PacketReceived(ByVal Packet As String) '---- packet received on the access control channel Call Status.ShowStatus(vbCrLf & Packet, , True, "Packet", vbBlue) End Sub Private Sub PopControl_WSAError(ByVal error_number As Integer) Call Status.ShowStatus("The following error occurred: " & error_number, vbRed, True, "Error", vbBlack) End Sub Private Sub Exit_Click() Dim i As Integer ' We don't know if we're actually connected or not. ' If we're not, calling QUIT will take a long time, ' because we're waiting for a server response. Shorten ' the timeout, since we don't care at this point if or ' how the server (if any) responds. SMTPControl.RecvTimeout = 200 PopControl.RecvTimeout = 200 '---- quit the mail channel SMTPControl.QUIT PopControl.QUIT '---- destroy all forms created by the control panel On Error Resume Next For i = 0 To (ciMaxReceiveMsg - 1) Unload ReceiveForms(i) Set ReceiveForms(i) = Nothing Next For i = 0 To (ciMaxSendMsg - 1) Unload SendForms(i) Set SendForms(i) = Nothing Next On Error GoTo 0 ExitProc End Sub Private Sub MailLogo_Click() AboutBox.Show vbModal End Sub Private Sub MailProperties_Click() Properties.Show vbModal End Sub '------------------------------------------------- '<Purpose> creates a new instance of a recieve ' form if one is available '------------------------------------------------- Private Function NewReceiveForm() As Integer Dim i As Integer Dim NumberReceiveForms As Integer For i = 0 To (ciMaxReceiveMsg - 1) NumberReceiveForms = NumberReceiveForms + 1 If (ReceiveForms(i) Is Nothing) Then Set ReceiveForms(i) = New Receive ReceiveForms(i).FormNumber = i NewReceiveForm = i Exit For End If Next GetMail.Enabled = (NumberReceiveForms < ciMaxReceiveMsg) If (NumberReceiveForms = ciMaxReceiveMsg) Then NewReceiveForm = citInvalidForm MsgBox "Unable to receive more then " & ciMaxReceiveMsg & " messages at a time.", vbOKOnly + vbInformation, "Receive Message" End If End Function Private Sub GetMail_Click() Dim i As Integer Dim LastMessage As Integer Dim NumberMessages As Integer '---- check for new messages NumberMessages = CheckMessages() If (NumberMessages = 0) Then MsgBox "You do not have any new mail.", vbOKOnly + vbInformation, "Receive Mail" End If For i = 1 To NumberMessages If (i = 1) Then LastMessage = ReceiveMessage(i) Else '---- offset additional messages LastMessage = ReceiveMessage(i, LastMessage) End If Next '---- close the POP control PopControl.QUIT DoEvents End Sub Private Sub SendMail_Click() Call NewSendForm(True) End Sub Private Sub Form_Load() Call GetWindowState(Me, "InternetMailMainWindow", False) Me.Width = 5370 End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Set CurrentSendForm = Nothing Call SetWindowState(Me, "InternetMailMainWindow") ExitProc End Sub '----------------------------------------------------- '<Purpose> cleans up a receive form '----------------------------------------------------- Public Sub DestroyReceiveForm(FormNumber As Integer) On Error Resume Next Unload ReceiveForms(FormNumber) Set ReceiveForms(FormNumber) = Nothing On Error GoTo 0 GetMail.Enabled = True End Sub '----------------------------------------------------- '<Purpose> cleans up a send form '----------------------------------------------------- Public Sub DestroySendForm(FormNumber As Integer) Unload SendForms(FormNumber) Set SendForms(FormNumber) = Nothing SendMail.Enabled = True End Sub Private Sub SMTPControl_PacketReceived(ByVal Packet As String) '---- packet received on the access control channel Call Status.ShowStatus(vbCrLf & Packet, , True, "Packet", vbBlue) End Sub '-------------------------------------------------- '<Purpose> sends a mail message with an attachment '-------------------------------------------------- Public Function EncodeAttachment() As Boolean On Error GoTo BadAttachment With MimeControl .FireStatus = True .SourceFilename = CurrentSendForm.AttachmentName .DestinationFileName = "c:\$$$cimime.tmp" .MIMEEncode End With EncodeAttachment = True On Error GoTo 0 Exit Function BadAttachment: On Error GoTo 0 EncodeAttachment = False End Function '------------------------------------------------------------ '<Purpose> actually sends a message '<Note> this demo sends messages and attachments separately '------------------------------------------------------------ Public Function ProcessMail() As Boolean Dim Result As Integer Dim ErrorType As String '---- hide the form while processing CurrentSendForm.Hide Me.Refresh If IsAttachment Then 'If SendMailMessage(False) Then '---- this call will start the encoding process which will then send the message ProcessMail = EncodeAttachment() 'Else ' ProcessMail = False 'End If Else ProcessMail = SendMailMessage(False) Unload CurrentSendForm End If End Function '--------------------------------------------------------- '<Purpose> Creates a mime header and message boundary '--------------------------------------------------------- Private Function AddMimeHeader(Boundary As String) As String Dim i As Integer Dim Char As Integer Dim Header As String Randomize Timer Boundary = "PART_BOUNDARY_" For i = 1 To 10 Char = Int((26 * Rnd) + 1) Boundary = Boundary & Chr$(Char + 64) Next Header = "Mime-Version: 1.0" & vbCrLf Header = Header & "Content-Type: multipart/mixed; boundary=" & Chr$(34) & Boundary & Chr$(34) & vbCrLf AddMimeHeader = Header & vbCrLf End Function '--------------------------------------------------------- '<Purpose> actually sends a message '--------------------------------------------------------- Private Function SendMailMessage(SendAttachment As Boolean) As Boolean Dim AttachmentRead As Boolean Dim Result As Integer Dim ErrorType As String Dim MessageBody As String Dim MessageBoundary As String Dim xmailer_old As String '---- store the original value of the .xmailer property '---- it needs to be restored after the message is sent xmailer_old = SMTPControl.XMailer '---- general send properties With Properties SMTPControl.DomainName = .DomainName '---- optional SMTPControl.Sender = .SenderName '---- required SMTPControl.HostName = .SendHostName '---- required SMTPControl.HostAddress = .SendHostAddress '---- required End With '---- message specific send properties With CurrentSendForm SMTPControl.Recipient = .SendTo '---- required SMTPControl.CC = .CopyTo '---- optional SMTPControl.MessageSubject = .Subject '---- suggested '---- now send message body, either text or attachment If SendAttachment Then AttachmentRead = ReadTempFile(MimeControl.DestinationFileName) If (Not AttachmentRead) Then MsgBox "An error occurred reading the encoded attachment.", vbOKOnly + vbExclamation, "Send Attachment" SendMailMessage = False GoTo Cleanup End If SMTPControl.XMailer = SMTPControl.XMailer & vbCrLf & AddMimeHeader(MessageBoundary) MessageBody = "--" & MessageBoundary & vbCrLf MessageBody = MessageBody & "Content-Type: text/plain; charset=us-ascii" & vbCrLf & vbCrLf MessageBody = MessageBody & .MessageText & vbCrLf & vbCrLf MessageBody = MessageBody & "--" & MessageBoundary & vbCrLf MessageBody = MessageBody & AttachmentStream & vbCrLf & vbCrLf MessageBody = MessageBody & "--" & MessageBoundary & "--" & vbCrLf SMTPControl.MessageBody = MessageBody Else SMTPControl.MessageBody = .MessageText End If End With '---- connect to the server Result = SMTPControl.ConnectToSMTPServer If (Not (Result > 0)) Then ErrorType = "ConnectToSMTPServer" GoTo ShowError End If Call Status.ShowStatus("Connecting to mail server", vbBlack, , "Status", vbRed) '---- say "hello" Result = SMTPControl.HELO If (Result <> citSuccess) Then ErrorType = "HELO" GoTo ShowError End If Call Status.ShowStatus("Say Hello", vbBlack, , "Status", vbRed) '---- forward the sender to the mail system Result = SMTPControl.MAIL If (Result <> citSuccess) Then ErrorType = "HELO" GoTo ShowError End If Call Status.ShowStatus("Sender forwarded", vbBlack, , "Status", vbRed) '---- forward the recipient to the mail system Result = SMTPControl.RCPT If (Result <> citSuccess) Then ErrorType = "RCPT" GoTo ShowError End If Call Status.ShowStatus("Recipient forwarded", vbBlack, , "Status", vbRed) '---- send the mail message Result = SMTPControl.Data If (Result <> citSuccess) Then ErrorType = "Data" GoTo ShowError End If Call Status.ShowStatus("Mail sent successfully", vbBlack, , "SendMail", vbRed) SendMailMessage = True SMTPControl.XMailer = xmailer_old Cleanup: SMTPControl.XMailer = xmailer_old Result = SMTPControl.QUIT DoEvents Exit Function ShowError: MsgBox "A ConnectToSMTPServer method error occurred.", vbOKOnly + vbInformation, "Send Message" SendMailMessage = False GoTo Cleanup End Function '----------------------------------------------------------------- '<Purpose> connects to a POP server and checks for messages '----------------------------------------------------------------- Private Function CheckMessages() As Integer Dim Result As Integer Dim SocketNumber As Integer With Properties '---- validate required fields If ((.SendHostName = "") Or (.UserName = "") Or (.Password = "")) Then MsgBox "The Host Name, Login Name and Password fields are all required. Set them using the 'Properties' dialog.", vbOKOnly + vbInformation, "Receive Mail" CheckMessages = -1 Exit Function End If '---- set the POP control properties PopControl.HostName = .ReceiveHostName PopControl.HostAddress = .ReceiveHostAddress PopControl.UserName = .UserName PopControl.Password = .Password End With '---- create a connection to the server SocketNumber = PopControl.ConnectToPOPServer If (SocketNumber = 0) Then MsgBox "Unable to establish a valid socket.", vbOKOnly + vbExclamation, "Receive Mail" PopControl.QUIT DoEvents CheckMessages = -1 Exit Function End If '---- get the mail Result = PopControl.USER Result = PopControl.PASS Result = PopControl.STAT CheckMessages = PopControl.TotalMessages End Function '------------------------------------------------------------- '<Purpose> issues the retrieve command 'RETR' to actually ' get a message '------------------------------------------------------------- Private Function ReceiveMessage(MessageNumber As Integer, Optional LastMessage As Variant) As Integer Dim Offset As Boolean Dim CharPos As Integer Dim FormNumber As Integer Dim OffsetLeft As Integer Dim OffsetTop As Integer Dim Result As Integer Dim Body As String Dim DestinationFileName As String Dim i As Integer '---- retrieve the message PopControl.MessageNumber = MessageNumber PopControl.LocalFileName = "c:\$$Mail.tmp" Result = PopControl.RETR If (Result <> citSuccess) Then MsgBox "Unable to retrieve message number " & MessageNumber, vbOKOnly + vbInformation, "Receive Message" ReceiveMessage = citInvalidForm Exit Function End If '---- working with objects can generate errors On Error GoTo BadForm '---- create a new instance of a receive form FormNumber = NewReceiveForm() If (FormNumber <> citInvalidForm) Then '---- calculate offset, if any If (Not IsMissing(LastMessage)) Then OffsetLeft = ReceiveForms(LastMessage).left + citFormOffset OffsetTop = ReceiveForms(LastMessage).Top + citFormOffset Offset = True End If '---- populate and show the form With ReceiveForms(FormNumber) .Caption = PopControl.MessageSubject .MessageSubject = PopControl.MessageSubject .MessageDate = PopControl.MessageDate .MessageHeader = PopControl.MessageHeader '---- may have extra CrLf at begginning !! Body = PopControl.MessageBody If (left(Body, 2) = vbCrLf) Then Body = Mid(Body, 3) '---- check for attachment 'IsAttachment = CheckForAttachment(PopControl.LocalFileName, DestinationFileName, MessageNumber) 'If (Not IsAttachment) Then ' .MessageBody = Body 'Else ReDim Attachments(0 To 0) '---- MIME attachment On Error GoTo CannotDecode With MimeControl .SourceFilename = PopControl.LocalFileName .DestinationFileName = DestinationFileName NumAttachments = 0 Result = .MIMEDecode End With If Result Then Do DoEvents Loop While NumAttachments >= 0 .MessageBody = ExtractMessageBody(Attachments(0)) .MessageBody = .MessageBody & vbCrLf & "Attachments:" & vbCrLf For i = 1 To UBound(Attachments) .MessageBody = .MessageBody & Attachments(i) & vbCrLf Next Else .MessageBody = Body End If On Error GoTo 0 'End If .ShowMessage '---- set offset If Offset Then Call .ShowOffset(OffsetLeft, OffsetTop) End If .Show End With End If ReceiveMessage = FormNumber On Error GoTo 0 Exit Function BadForm: ReceiveMessage = citInvalidForm On Error GoTo 0 Exit Function CannotDecode: ReceiveMessage = citInvalidForm On Error GoTo 0 End Function '-------------------------------------------------------- ' <Purpose> reply to a previously received mail message '-------------------------------------------------------- Public Function ReplyToMessage(ThisForm As Form) Dim FormNumber As Integer '---- create new form FormNumber = NewSendForm(False) '---- now show the form With SendForms(FormNumber) .SendTo = ThisForm.MessageFrom .Subject = "Reply to: " & ThisForm.MessageSubject .MessageText = "> In reply to your subject message:" & vbCrLf .Show End With End Function '-------------------------------------------------------- ' <Purpose> select a file as an attachment '-------------------------------------------------------- Public Function SelectFile(DefaultExt As String, DialogTitle As String) As String On Error GoTo UserCancelled With ComDialog .FileName = "" .DefaultExt = DefaultExt .DialogTitle = DialogTitle .Flags = cdlOFNHideReadOnly Or cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNShareAware ComDialog.Action = 1 SelectFile = .FileName End With On Error GoTo 0 Exit Function UserCancelled: SelectFile = "" On Error GoTo 0 End Function '------------------------------------------------- '<Purpose> creates a new instance of a send ' form if one is available '------------------------------------------------- Private Function NewSendForm(ShowForm As Boolean) As Integer Dim i As Integer Dim NumberSendForms As Integer Dim OffsetLeft As Integer Dim OffsetTop As Integer Static FirstLeft As Integer Static FirstTop As Integer For i = 0 To (ciMaxSendMsg - 1) NumberSendForms = NumberSendForms + 1 If (SendForms(i) Is Nothing) Then NewSendForm = i Set SendForms(i) = New Send With SendForms(i) .FormNumber = i .Caption = "Send Mail (#" & i + 1 & ")" '---- calculate and show offsets If (i > 0) Then OffsetLeft = FirstLeft + (i * citFormOffset) OffsetTop = FirstTop + (i * citFormOffset) Call .ShowOffset(OffsetLeft, OffsetTop) End If If ShowForm Then .Show '---- cache the first left and top to offset new forms If (i = 0) Then FirstLeft = SendForms(0).left FirstTop = SendForms(0).Top End If End With Exit For End If Next SendMail.Enabled = (NumberSendForms < ciMaxSendMsg) End Function 
(.txt)